home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1994 August: Tool Chest / Dev.CD Aug 94.toast / Tool Chest / Development Platforms / Macintosh Common Lisp Related / User Contributions / think-ref-lookup.lisp < prev    next >
Encoding:
Text File  |  1994-06-22  |  4.4 KB  |  113 lines  |  [TEXT/CCL2]
  1. ;
  2. ;  think-ref-lookup.lisp
  3. ;
  4. ;  This code enables you to lookup THINK Reference (TM) from Fred editor.
  5. ;  If you load this file, the lookup function ed-think-reference is bound to m-r.
  6. ;
  7. ;  The Original code is posted to info-mcl@cambridge.apple.com on 12/1/1993
  8. ;  by Jeffrey B Kane (jbk@world.std.com).
  9. ;  I added some faculties
  10. ;  * to launch THINK Reference (TM) if you have not loaded it yet.
  11. ;  * to get the current S expression and lookup if it is a symbol.
  12. ;  * to handle appleevent-error and display its message to mini-buffer.
  13. ;
  14. ;  And on Bill St. Clair's (bill@cambridge.apple.com) advice, I changed my code
  15. ;  to search THINK Reference (TM) with _PBDTGetAPPL. I referd to his code
  16. ;  in the file cambridge.apple.com /pub/mcl2/contrib/processes.lisp.
  17. ;
  18. ;  Special thanks for Jeffery and Bill.
  19. ;
  20. ;  Masaya UEDA    ueda@shpcsl.sharp.co.jp
  21.  
  22. (eval-when (:compile-toplevel :execute :load-toplevel)
  23.   (require :appleevent-toolkit))
  24.  
  25. (defun get-creator-path-aux (creator fsspec)
  26.   (let ((devs (directory "*:")))
  27.     (dolist (vrefnum (sort (mapcar 'volume-number devs) #'>))
  28.       (rlet ((pb :DTPBRec
  29.                  :ioNamePtr (%null-ptr)
  30.                  :ioVRefnum vrefnum))
  31.         (when (= (#_PBDTGetPath pb) #$noErr)
  32.           (setf (rref pb :DTPBRec.ioNamePtr)
  33.                 (%inc-ptr fsspec (get-field-offset :fsspec.name))
  34.                 (pref pb :DTPBRec.ioIndex) 0
  35.                 (pref pb :DTPBRec.ioFileCreator) creator)
  36.           (when (= (#_PBDTGetAPPL pb) #$noErr)
  37.             (setf (pref fsspec :fsspec.vRefnum) vrefnum
  38.                   (pref fsspec :fsspec.parID) (pref pb :DTPBRec.ioAPPLParID))
  39.             (return (values))))))))
  40.  
  41. (defun get-creator-path (creator)
  42.   (rlet ((fsspec :fsspec))
  43.     (get-creator-path-aux creator fsspec)
  44.     (%path-from-fsspec fsspec)))
  45.  
  46. (defun launch-application-aux (sfFile)
  47.   (rlet ((lpb :LaunchParamBlockRec
  48.               :launchBlockID #$extendedBlock
  49.               :launchEPBLength #$extendedBlockLen
  50.               :launchFileFlags 0
  51.               :launchControlFlags (+ #$launchContinue #$launchNoFileFlags)
  52.               :launchAppSpec sfFile
  53.               :launchAppParameters (%null-ptr)))
  54.     (if (= (#_LaunchApplication lpb) #$noErr)
  55.       (values (rref lpb :LaunchParamBlockRec.launchProcessSN.highLongOfPSN)
  56.               (rref lpb :LaunchParamBlockRec.launchProcessSN.LowLongOfPSN)))))
  57.  
  58. (defun launch-application (filename &aux (pf (probe-file filename)))
  59.   (if pf
  60.     (rlet ((fsspec :FSSpec))
  61.       (with-pstrs ((name (mac-namestring pf)))
  62.         (#_FSMakeFSSpec 0 0 name fsspec))
  63.       (launch-application-aux fsspec))))
  64.  
  65. (defun Think-Ref (search-string)
  66.   (flet ((strlen (cstring)
  67.            (if (macptrp cstring)
  68.              (let ((n 0))
  69.                (loop
  70.                  (if (= (%get-byte cstring n) 0)
  71.                    (return n)
  72.                    (incf n))))
  73.              nil)))
  74.     (with-aedescs (ae target reply)
  75.       (with-cstrs ((my-cstring search-string))
  76.         (multiple-value-bind (psnhigh psnlow) (find-process-with-signature :|DanR|)
  77.           (unless psnhigh
  78.             (multiple-value-setq (psnhigh psnlow)
  79.               (rlet ((fsspec :fsspec))
  80.                 (get-creator-path-aux :|DanR| fsspec)
  81.                 (launch-application-aux fsspec))))
  82.           (when psnhigh
  83.             (create-psn-target target psnhigh psnlow)
  84.             ;; create an apple event
  85.             (ae-error (#_AECreateAppleEvent
  86.                        :|DanR|
  87.                        :|REF |
  88.                        target
  89.                        #$kAutoGenerateReturnID
  90.                        #$kAnyTransactionID
  91.                        ae))
  92.             ;; stuff it with our parameters
  93.             (ae-error (#_AEPutParamPtr
  94.                        ae
  95.                        #$keyDirectObject
  96.                        #$typeChar
  97.                        my-cstring
  98.                        (strlen my-cstring)))
  99.             ;; send it off
  100.             (send-appleevent ae reply :reply-mode :wait-reply)))))))
  101.  
  102. (defmethod ed-think-reference ((fm fred-mixin))
  103.   (let ((sym (ed-current-sexp fm))) 
  104.     (when (and sym (symbolp sym))
  105.       (let ((sn (symbol-name sym)))
  106.         (when (or (char= #\_ (char sn 0)) (char= #\$ (char sn 0)))
  107.           (setq sn (subseq sn 1)))
  108.         (handler-case (Think-Ref sn)
  109.           (appleevent-error (condition)
  110.                             (format (view-mini-buffer fm) "~a: ~a"
  111.                                     sym condition)))))))
  112.  
  113. (def-fred-command (:meta #\r) ed-think-reference)